{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Lambola.IDL.ParsecParser
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Parser.
-- 
--------------------------------------------------------------------------------

module Lambola.IDL.ParsecParser
 
  where

import Lambola.IDL.ParsecLexer
import Lambola.IDL.Syntax


import Text.Parsec
-- import Text.Parsec.Expr

import Control.Applicative hiding ( (<|>), many )


testParser :: IDLParser a -> String -> Either ParseError a
testParser p s = runParser p () "" s


prefix :: IDLParser a -> (a -> IDLParser b) -> (a -> IDLParser b) -> IDLParser b
prefix ma alt1 alt2 = ma >>= \a -> (alt1 a) <|> (alt2 a)


prefixs :: IDLParser a -> [a -> IDLParser b] -> IDLParser b
prefixs ma alts = ma >>= \a -> choice (map ($ a) alts)



-- | (1) specification

specification :: IDLParser [Definition]
specification = whiteSpace *> many1 definition


-- | (2) definition
--
definition :: IDLParser Definition
definition = (body `terminated` semi) <?> "definition" 
  where
    body =  typeDcl
        <|> constDcl
        <|> exceptDcl
        <|> attrDcl
        <|> interface
        <|> idlmodule



-- | (3) module
idlmodule :: IDLParser Definition
idlmodule = 
    Module <$> (keyword "module" *> identifier) <*> braces (many1 definition)


-- | (4) interface
--
interface :: IDLParser Definition
interface = prefix (keyword "interface" *> identifier) interfaceDcl1 forwardDcl1


-- | (5) interface dcl ("interface" identifier - consumed)
--
interfaceDcl1 :: Identifier -> IDLParser Definition
interfaceDcl1 ident = fn <$> interfaceHeader1 ident <*> braces interfaceBody
  where
    fn (_,names) body = InterfaceDcl ident names body


-- | (6) forward dcl ("interface" identifier - consumed)
-- 
forwardDcl1 :: Identifier -> IDLParser Definition
forwardDcl1 ident = pure $ ForwardDcl ident


-- | (7) interface header ("interface" identifier - consumed)
-- 
interfaceHeader1 :: Identifier -> IDLParser (Identifier,[ScopedName])
interfaceHeader1 ident = fn <$> optionMaybe inheritanceSpec
  where
    fn = maybe (ident,[]) (\xs -> (ident,xs))


-- | (8) interface body
--
interfaceBody :: IDLParser [Definition]
interfaceBody = many export


-- | (9) export
--
export :: IDLParser Definition
export = (body `terminated` semi) <?> "export"
  where
    body =  typeDcl
        <|> constDcl
        <|> exceptDcl
        <|> attrDcl
        <|> opDcl
        

-- | (10) inheritance spec
-- 
inheritanceSpec :: IDLParser [ScopedName]
inheritanceSpec = colon *> sepBy1 scopedName comma


-- | (11) Scoped Name
--
scopedName :: IDLParser ScopedName
scopedName = fn [] =<< sepBy1 identifier (operator "::")
  where
    fn _   []     = fail "scopedName"
    fn acc [x]    = return $ ScopedName acc x
    fn acc (x:xs) = fn (acc++[x]) xs

tyScopedName :: IDLParser TypeSpec
tyScopedName = TyNamed <$> scopedName

-- | (12) const dcl
-- 
constDcl :: IDLParser Definition
constDcl = ConstDcl <$> (keyword "const" *> constType)
                    <*> identifier 
                    <*> (operator "=" *> constExp)

-- | (13) const type
--
constType :: IDLParser TypeSpec
constType =  integerType
         <|> charType
         <|> booleanType
         <|> floatingPtType
         <|> stringType
         <|> tyScopedName


-- | (14) const exp
-- 
constExp :: IDLParser ConstExp
constExp = unaryExpr

-- | (15) or expr
-- 
orExpr :: IDLParser ConstExp
orExpr = chainl1 primaryExpr (BinaryExp <$> pOp)
  where
    pOp  =  (BIN_OR <$ operator "|")


-- | (16) xor expr
-- 
xorExpr :: IDLParser ConstExp
xorExpr = chainl1 orExpr (BinaryExp <$> pOp)
  where
    pOp  =  (BIN_XOR <$ operator "^")

-- | (17) and expr
-- 
andExpr :: IDLParser ConstExp
andExpr = chainl1 xorExpr (BinaryExp <$> pOp)
  where
    pOp  =  (BIN_AND <$ operator "&")

-- | (18) shift expr
-- 
shiftExpr :: IDLParser ConstExp
shiftExpr = chainl1 andExpr (BinaryExp <$> pOps)
  where
    pOps =  (BIN_SHIFTR <$ operator ">>")
        <|> (BIN_SHIFTL <$ operator "<<")


-- | (19) add expr
-- 
addExpr :: IDLParser ConstExp
addExpr = chainl1 shiftExpr (BinaryExp <$> pOps)
  where
    pOps =  (BIN_PLUS  <$ operator "+")
        <|> (BIN_MINUS <$ operator "-")


-- | (20) unary expr
-- 
multExpr :: IDLParser ConstExp
multExpr = chainl1 addExpr (BinaryExp <$> pOps)
  where
    pOps =  (BIN_MULT <$ operator "*")
        <|> (BIN_DIV  <$ operator "/")
        <|> (BIN_MOD  <$ operator "%")


-- | (21) unary expr
-- 
unaryExpr :: IDLParser ConstExp
unaryExpr =  (UnaryExp <$> unaryOperator <*> constExp)
         <|> multExpr


-- | (22) unary operator
--
unaryOperator :: IDLParser UnaryOp
unaryOperator =  (UNARY_NEGATE  <$ operator "-")
             <|> (UNARY_PLUS    <$ operator "+")
             <|> (UNARY_BNOT    <$ operator "~")

-- | (23) primary expr
-- 
primaryExpr :: IDLParser ConstExp
primaryExpr =  (NamedExp <$> scopedName)
           <|> literal
           <|> parens (constExp) 

-- | (24) literal
-- 
literal :: IDLParser ConstExp
literal =  (IntegerLit    <$> decimal)
       <|> (StringLit     <$> stringLiteral)
       <|> (CharLit       <$> charLiteral)
       <|> (FloatingPtLit <$> float)
       <|> booleanLiteral

-- | (25) boolean literal
--
booleanLiteral :: IDLParser ConstExp
booleanLiteral = pTrue <|> pFalse
  where
    pTrue   = BooleanLit True  <$ keyword "TRUE"
    pFalse  = BooleanLit False <$ keyword "FALSE"


-- | (26) positive int const
-- 
positiveIntConst :: IDLParser ConstExp
positiveIntConst = constExp <?> "positive int const"


-- | (27) type decl
--
typeDcl :: IDLParser Definition
typeDcl =  pTypedef
       <|> liftDcl structType
       <|> liftDcl unionType
       <|> liftDcl enumType
       <?> "type decl"
  where
    pTypedef  = uncurry TypedefDcl <$> (keyword "typedef" *> typeDeclarator)
    liftDcl p = TypeDcl <$> p


-- | (28) type declarator
-- 
typeDeclarator :: IDLParser (TypeSpec, [Declarator])
typeDeclarator = (,) <$> typeSpec <*> declarators


-- | (29) type spec
--
typeSpec :: IDLParser TypeSpec
typeSpec = simpleTypeSpec <|> constrTypeSpec
        <?> "type spec"


-- | (30) simple type spec
--
simpleTypeSpec :: IDLParser TypeSpec
simpleTypeSpec =  baseTypeSpec
              <|> templateTypeSpec
              <|> tyScopedName
              <?> "simple type spec"

-- | (31) base type spec
--
baseTypeSpec :: IDLParser TypeSpec
baseTypeSpec =  floatingPtType
            <|> integerType
            <|> charType
            <|> booleanType
            <|> octetType
            <|> anyType


-- | (32) template type spec
-- 
templateTypeSpec :: IDLParser TypeSpec
templateTypeSpec =  sequenceType
                <|> stringType


-- | (33) constr type spec
--
constrTypeSpec :: IDLParser TypeSpec
constrTypeSpec =  structType
              <|> unionType
              <|> enumType


-- | (34) declarators 
--
declarators :: IDLParser [Declarator]
declarators = sepBy1 declarator comma


-- | (35) declarator
--
-- TODO - common prefix
--
declarator :: IDLParser Declarator
declarator =  simpleDeclarator
          <|> complexDeclarator


-- | (36) simple declarator
-- 
simpleDeclarator :: IDLParser Declarator
simpleDeclarator = SimpleDeclarator <$> identifier


-- | (37) complex declarator
complexDeclarator :: IDLParser Declarator
complexDeclarator = arrayDeclarator


-- | (38) floating pt type
--
floatingPtType :: IDLParser TypeSpec
floatingPtType = pFloat <|> pDouble
  where
    pFloat  = TyFloat FLOAT  <$ keyword "float"
    pDouble = TyFloat DOUBLE <$ keyword "double"


-- | (39) integer type
--
integerType :: IDLParser TypeSpec
integerType = signedInt <|> unsignedInt


-- | (40) signed int
-- 
signedInt :: IDLParser TypeSpec
signedInt = signedLongInt <|> signedShortInt


-- | (41) signed long int
--
signedLongInt :: IDLParser TypeSpec
signedLongInt = TyInt SIGNED_LONG_INT <$ keyword "long"


-- | (42) signed short int
--
signedShortInt :: IDLParser TypeSpec
signedShortInt = TyInt SIGNED_SHORT_INT <$ keyword "short"


-- | (43) unsigned int
-- 
unsignedInt :: IDLParser TypeSpec
unsignedInt = keyword "unsigned" *> (unsignedLongInt1 <|> unsignedShortInt1)


-- | (44) unsigned long int ("unsigned" consumed)
--
unsignedLongInt1 :: IDLParser TypeSpec
unsignedLongInt1 = TyInt UNSIGNED_LONG_INT  <$ keyword "long"


-- | (45) unsigned short int ("unsigned" consumed)
--
unsignedShortInt1 :: IDLParser TypeSpec
unsignedShortInt1 = TyInt UNSIGNED_SHORT_INT <$ keyword "short"


-- | (46) char type
--
charType :: IDLParser TypeSpec
charType = TyChar <$ keyword "char"


-- | (47) boolean type
--
booleanType :: IDLParser TypeSpec
booleanType = TyBoolean <$ keyword "boolean"


-- | (48) octet type
--
octetType :: IDLParser TypeSpec
octetType = TyOctet <$ keyword "octet"


-- | (49) any type
--
anyType :: IDLParser TypeSpec
anyType = TyAny <$ keyword "any"


-- | (50) struct type
--
-- Note the grammar includes a comment stating that 
-- /structure types may also be names using a typedef declaration/.
-- 
-- Such structs need a post-processing phase eliminating the dummy
-- identifier @%unresolved@.
-- 
structType :: IDLParser TypeSpec
structType = TyStruct <$> (keyword "struct" *> unresolvedIdentifier) 
                      <*> braces memberList
          <?> "struct type"
           
-- | (51) member list
--
memberList :: IDLParser [Member]
memberList = many1 member


-- | (52) member
--
member :: IDLParser Member
member = Member <$> typeSpec <*> (declarators <* semi)


-- | (53) union type
--
unionType :: IDLParser TypeSpec
unionType = TyUnion <$> (keyword "union" *> identifier)
                    <*> (keyword "switch" *> parens switchTypeSpec)
                    <*> braces switchBody


-- | (54) switch type spec 
-- 
switchTypeSpec :: IDLParser TypeSpec
switchTypeSpec =  integerType
              <|> charType
              <|> booleanType
              <|> enumType
              <|> tyScopedName


-- | (55) switch body
--
switchBody :: IDLParser [UnionCase]
switchBody = many1 unionCase


-- | (56) case
--
unionCase :: IDLParser UnionCase
unionCase = UnionCase <$> many1 caseLabel <*> (elementSpec <* semi)


-- | (57) case label
--
caseLabel :: IDLParser CaseLabel
caseLabel = pCase <|> pDefault
  where
    pCase    = CaseOf      <$> (keyword "case" *> constExp <* colon)
    pDefault = CaseDefault <$  (keyword "default" <* colon)


-- | (58) element spec
--
elementSpec :: IDLParser ElementSpec
elementSpec = ElementSpec <$> typeSpec <*> declarator


-- | (59) enum type
--
enumType :: IDLParser TypeSpec
enumType = TyEnum <$> identifier <*> braces (sepBy1 enumerator comma)


-- | (60) enumerator
--
enumerator :: IDLParser Identifier
enumerator = identifier


-- | (61) sequenceType
-- 
sequenceType :: IDLParser TypeSpec
sequenceType = keyword "sequence" *> angles body
  where
    body = TySequence <$> simpleTypeSpec 
                      <*> optionMaybe (comma *> positiveIntConst)


-- | (62) string type
--
stringType :: IDLParser TypeSpec
stringType = TyString <$> (keyword "string" *> optionMaybe pLength) 
  where
    pLength = angles positiveIntConst


-- | (63) array declarator
--
arrayDeclarator :: IDLParser Declarator 
arrayDeclarator = ArrayDeclarator <$> identifier <*> many1 fixedArraySize


-- | (64) fixed array size
--
fixedArraySize :: IDLParser ConstExp
fixedArraySize = squares positiveIntConst


-- | (65) attr dcl
--
attrDcl :: IDLParser Definition
attrDcl = AttrDcl  <$> (optReadonly <* keyword "attribute")
                   <*> paramTypeSpec
                   <*> sepBy1 simpleDeclarator comma
  where
    optReadonly = maybe ACCESS_RW id <$> optionMaybe readonly
    readonly    = READONLY <$ keyword "readonly"

    


-- | (66) except dcl
--
exceptDcl :: IDLParser Definition
exceptDcl = ExceptDcl <$> (keyword "exception" *> identifier)
                      <*> braces (many member)

-- | (67) op dcl
--
-- note - opAttribute accounts for optional.
--
opDcl :: IDLParser Definition
opDcl = OpDcl <$> opAttribute 
              <*> opTypeSpec 
              <*> identifier 
              <*> parameterDcls
              <*> optionMaybe raisesExpr
              <*> optionMaybe contextExpr

-- | (68) op attribute
--
opAttribute :: IDLParser OpAttribute
opAttribute = pOneway <|> return NO_ATTR
  where
    pOneway = ONEWAY <$ keyword "oneway"

-- | (69) op type spec
--
opTypeSpec :: IDLParser TypeSpec
opTypeSpec = paramTypeSpec <|> tyVoid
  where
    tyVoid = TyVoid <$ keyword "void"


-- | (70) parameter dcls
--
parameterDcls :: IDLParser [ParamDcl]
parameterDcls = parens (sepBy paramDcl comma)

-- | (71) param dcl
paramDcl :: IDLParser ParamDcl
paramDcl = ParamDcl <$> paramAttribute <*> paramTypeSpec <*> simpleDeclarator


-- | (72) param attribute
--
paramAttribute :: IDLParser ParamAttribute
paramAttribute = pInout <|> pIn <|> pOut
  where
    pIn     = IN    <$ keyword "in"
    pOut    = OUT   <$ keyword "out"
    pInout  = INOUT <$ keyword "inout"

-- | (73) raises expr
-- 
raisesExpr :: IDLParser RaisesExpr
raisesExpr = keyword "raises" *> parens (sepBy1 scopedName comma)

-- (74) context expr
--
contextExpr :: IDLParser ContextExpr
contextExpr = keyword "context" *> parens (sepBy1 stringLiteral comma)


-- | (75) param type spec
--
paramTypeSpec :: IDLParser TypeSpec
paramTypeSpec =  baseTypeSpec
             <|> stringType
             <|> tyScopedName